home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Travers' lisp contrib.sea / Travers' lisp contrib / read-eval-inspect.lisp < prev    next >
Encoding:
Text File  |  1992-01-17  |  4.6 KB  |  123 lines  |  [TEXT/CCL2]
  1. (in-package :cl-user)
  2.  
  3. ;;; Read-eval-inspect 
  4. ;;; Michael Travers 5/91
  5. ;;; thanks to Henry Lieberman for original idea
  6.  
  7. #|
  8. This does two things:  1) results from the Listener get brought into a special inspector window
  9. (you can control what classes of objects get this treatment).  2)  The variable % will always
  10. be equal to the object in the topmost inspector.
  11.  
  12. You should also know about Option-clicking on lines within inspectors.  Try it.
  13.  
  14. Todo:
  15. - if item is already in an inspect window, just update it and bring it front
  16.  
  17. |#
  18.  
  19.  
  20. (defmethod inspect-new-thing ((w inspector::inspector-window) thing)
  21.   (catch :cancel
  22.     (inspector::install-new-inspector (view-container (inspector::inspector-view w) )
  23.                                       (inspector::make-inspector thing))
  24.     (set-window-layer w (1+ *windoid-count*))))
  25.    
  26.  
  27. (defvar *readloop-inspector* nil)
  28.  
  29. ;;; Access through this function to ensure the inspect window remains valid
  30. (defun readloop-inspector ()
  31.   (if (and *readloop-inspector*
  32.            (slot-value *readloop-inspector* 'wptr))
  33.     *readloop-inspector*
  34.     (multiple-value-bind (pos size) (inspector-position-and-size)
  35.       (setq *readloop-inspector* 
  36.             (make-instance 'inspector::inspector-window 
  37.                            :inspector (make-instance 'inspector::usual-inspector
  38.                                                      :object "Welcome to read-eval-inspect")
  39.                            :view-position pos
  40.                            :view-size size))
  41.       ;; Init arg doesn't work.
  42.       (set-view-size *readloop-inspector* size)
  43.       *readloop-inspector*)))
  44.  
  45. (defun inspector-position-and-size ()
  46.   (let* ((l-position (view-position *top-listener*))
  47.          (l-size (view-size *top-listener*)))
  48.     (values (+ l-position (point-h l-size))
  49.             (make-point (- *screen-width* (+ (point-h l-position) (point-h l-size)))
  50.                         (point-v l-size)))))
  51.  
  52. ;;; Refinement - only inspect some classes
  53.  
  54. ;;; To be displayed, an object must be a subclass of some yes class, and also not be
  55. ;;; a subclass of all no classes.  Got that?  Either the yes or no class list can be
  56. ;;; nil in which case the check isn't done.
  57.  
  58. ;;; Theory behind these values is we want to see anything with structure not obvious from 
  59. ;;; its printed representation, but not every method def because they usually aren't interesting.
  60. (defparameter *readloop-inspector-yes-classes* '(standard-object structure macptr cons array))
  61. (defparameter *readloop-inspector-no-classes* '(standard-method string))
  62.  
  63. ;;; Menu control
  64.  
  65. (defvar *readloop-inspector-on* t)
  66.  
  67. (defvar *readloop-inspect-menu-item* 
  68.   (let ((it (make-instance 'menu-item
  69.                            :menu-item-title "Auto Inspect"
  70.                            :menu-item-action 'readloop-inspect-toggle)))
  71.     (add-menu-items *eval-menu*
  72.                     (make-instance 'menu-item :menu-item-title "-" :disabled t) 
  73.                     it)
  74.     (set-menu-item-check-mark it *readloop-inspector-on*)
  75.     it))
  76.  
  77. (defun readloop-inspect-toggle ()
  78.   (setq *readloop-inspector-on* (not *readloop-inspector-on*))
  79.   (set-menu-item-check-mark *readloop-inspect-menu-item* *readloop-inspector-on*))
  80.  
  81.  
  82. (defun maybe-inspect-new-thing (thing)
  83.   (when (and *readloop-inspector-on*
  84.              (and (or (null *readloop-inspector-yes-classes*)
  85.                       ;; I wonder if this is actually guaranteed valid in CL...
  86.                       (find thing *readloop-inspector-yes-classes* :test #'typep))
  87.                   (or (null *readloop-inspector-no-classes*)
  88.                       (not (find thing *readloop-inspector-no-classes* :test #'typep)))))
  89.     (inspect-new-thing (readloop-inspector) thing)))
  90.  
  91. ;;; Perhaps this could use evalhook instead of relying on an unadvertised function.
  92. (ccl:advise ccl::toplevel-eval
  93.              (progn
  94.                (without-interrupts
  95.                 (maybe-inspect-new-thing (caar values))))
  96.              :when :after :name :read-eval-inspect)
  97.  
  98. ;;; % feature
  99. ;;; separable from read-eval-inspect, actually
  100. (defvar ccl::% nil "The value in the top inspect window.")
  101.  
  102. (export 'ccl::% :ccl)
  103.  
  104. (defmethod window-select :after ((w inspector::inspector-window))
  105.   (setq ccl::% (inspector::inspector-object w)))
  106.  
  107. (advise inspector::push-inspector-history 
  108.         (setq ccl::% (top-inspect-form))
  109.         :when :after :name set-%)
  110.  
  111. ;;; First impressions are so important
  112. (eval-when (eval load)
  113.   (setq ccl::% (top-inspect-form)))
  114.  
  115. ;;; new:  update inspect history automatically
  116. (advise inspector::push-inspector-history 
  117.         (let ((ihw (find-window "inspector history")))
  118.           (when ihw
  119.             (inspector::resample ihw)))
  120.         :when :after :name update-history-window)
  121.  
  122. (provide :read-eval-inspect)
  123.